home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / ADA / GNAT / !gcc / adainc / 3 / adb / i-cpp < prev    next >
Text File  |  1996-02-12  |  10KB  |  311 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                       I N T E R F A C E S . C P P                        --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.9 $                              --
  10. --                                                                          --
  11. --     Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc.     --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with Ada.Tags;                use Ada.Tags;
  37. with Interfaces.C;            use Interfaces.C;
  38. with System;                  use System;
  39. with System.Storage_Elements; use System.Storage_Elements;
  40.  
  41. package body Interfaces.CPP is
  42.  
  43.    subtype Cstring is String (Positive);
  44.    type Cstring_Ptr is access all Cstring;
  45.    type Tag_Table is array (Natural range <>) of Vtable_Ptr;
  46.  
  47.    type Type_Specific_Data is record
  48.       Idepth        : Natural;
  49.       Expanded_Name : Cstring_Ptr;
  50.       External_Tag  : Cstring_Ptr;
  51.       HT_Link       : Tag;
  52.       Ancestor_Tags : Tag_Table (Natural);
  53.    end record;
  54.  
  55.    type Vtable_Entry is record
  56.      Delta1 : C.Short;
  57.      Index  : C.Short;
  58.      Pfn    : System.Address;
  59.    end record;
  60.  
  61.    type Type_Specific_Data_Ptr is access all Type_Specific_Data;
  62.    type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
  63.  
  64.    type VTable is record
  65.       Unused1   : C.Short;
  66.       Unused2   : C.Short;
  67.       TSD       : Type_Specific_Data_Ptr;
  68.       Prims_Ptr : Vtable_Entry_Array (Positive);
  69.    end record;
  70.  
  71.    --------------------------------------------------------
  72.    -- Unchecked Conversions for Tag, Vtable_Ptr, and TSD --
  73.    --------------------------------------------------------
  74.  
  75.    function To_Type_Specific_Data_Ptr is
  76.      new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);
  77.  
  78.    function To_Address is new Unchecked_Conversion (Vtable_Ptr, Address);
  79.    function To_Address is
  80.      new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);
  81.  
  82.    function To_Vtable_Ptr is new Unchecked_Conversion (Tag, Vtable_Ptr);
  83.    function To_Tag is new Unchecked_Conversion (Vtable_Ptr, Tag);
  84.  
  85.    ---------------------------------------------
  86.    -- Unchecked Conversions for String Fields --
  87.    ---------------------------------------------
  88.  
  89.    function To_Cstring_Ptr is
  90.      new Unchecked_Conversion (Address, Cstring_Ptr);
  91.  
  92.    function To_Address is
  93.      new Unchecked_Conversion (Cstring_Ptr, Address);
  94.  
  95.    -----------------------
  96.    -- Local Subprograms --
  97.    -----------------------
  98.  
  99.    function Length (Str : Cstring_Ptr) return Natural;
  100.    --  Length of string represented by the given pointer (treating the
  101.    --  string as a C-style string, which is Nul terminated).
  102.  
  103.    --------------------
  104.    -- Displaced_This --
  105.    --------------------
  106.  
  107.    function Displaced_This
  108.     (Current_This : System.Address;
  109.      Vptr         : Vtable_Ptr;
  110.      Position     : Positive)
  111.      return         System.Address
  112.    is
  113.    begin
  114.       return Current_This
  115.         + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
  116.    end Displaced_This;
  117.  
  118.    -----------------------
  119.    -- CPP_CW_Membership --
  120.    -----------------------
  121.  
  122.    function CPP_CW_Membership
  123.      (Obj_Tag : Vtable_Ptr;
  124.       Typ_Tag : Vtable_Ptr)
  125.       return Boolean
  126.    is
  127.       Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
  128.    begin
  129.       return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
  130.    end CPP_CW_Membership;
  131.  
  132.    ---------------------------
  133.    -- CPP_Get_Expanded_Name --
  134.    ---------------------------
  135.  
  136.    function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is
  137.    begin
  138.       return To_Address (T.TSD.Expanded_Name);
  139.    end CPP_Get_Expanded_Name;
  140.  
  141.    --------------------------
  142.    -- CPP_Get_External_Tag --
  143.    --------------------------
  144.  
  145.    function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
  146.    begin
  147.       return To_Address (T.TSD.External_Tag);
  148.    end CPP_Get_External_Tag;
  149.  
  150.    -------------------------------
  151.    -- CPP_Get_Inheritance_Depth --
  152.    -------------------------------
  153.  
  154.    function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is
  155.    begin
  156.       return T.TSD.Idepth;
  157.    end CPP_Get_Inheritance_Depth;
  158.  
  159.    -------------------------
  160.    -- CPP_Get_Prim_Op_Address --
  161.    -------------------------
  162.  
  163.    function CPP_Get_Prim_Op_Address
  164.      (T        : Vtable_Ptr;
  165.       Position : Positive)
  166.       return Address is
  167.    begin
  168.       return T.Prims_Ptr (Position).Pfn;
  169.    end CPP_Get_Prim_Op_Address;
  170.  
  171.    -----------------
  172.    -- CPP_Get_TSD --
  173.    -----------------
  174.  
  175.    function CPP_Get_TSD  (T : Vtable_Ptr) return Address is
  176.    begin
  177.       return To_Address (T.TSD);
  178.    end CPP_Get_TSD;
  179.  
  180.    --------------------
  181.    -- CPP_Inherit_DT --
  182.    --------------------
  183.  
  184.    procedure CPP_Inherit_DT
  185.     (Old_T   : Vtable_Ptr;
  186.      New_T   : Vtable_Ptr;
  187.      Entry_Count : Natural)
  188.    is
  189.    begin
  190.       if Old_T /= null then
  191.          New_T.Prims_Ptr (1 .. Entry_Count)
  192.            := Old_T.Prims_Ptr (1 .. Entry_Count);
  193.       end if;
  194.    end CPP_Inherit_DT;
  195.  
  196.    ---------------------
  197.    -- CPP_Inherit_TSD --
  198.    ---------------------
  199.  
  200.    procedure CPP_Inherit_TSD
  201.      (Old_TSD : Address;
  202.       New_Tag : Vtable_Ptr)
  203.    is
  204.       TSD : constant Type_Specific_Data_Ptr
  205.         := To_Type_Specific_Data_Ptr (Old_TSD);
  206.  
  207.       New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
  208.  
  209.    begin
  210.       if TSD /= null then
  211.          New_TSD.Idepth := TSD.Idepth + 1;
  212.          New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
  213.            := TSD.Ancestor_Tags (0 .. TSD.Idepth);
  214.       else
  215.          New_TSD.Idepth := 0;
  216.       end if;
  217.  
  218.       New_TSD.Ancestor_Tags (0) := New_Tag;
  219.    end CPP_Inherit_TSD;
  220.  
  221.    ---------------------------
  222.    -- CPP_Set_Expanded_Name --
  223.    ---------------------------
  224.  
  225.    procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
  226.    begin
  227.       T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
  228.    end CPP_Set_Expanded_Name;
  229.  
  230.    --------------------------
  231.    -- CPP_Set_External_Tag --
  232.    --------------------------
  233.  
  234.    procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
  235.    begin
  236.       T.TSD.External_Tag := To_Cstring_Ptr (Value);
  237.    end CPP_Set_External_Tag;
  238.  
  239.    -------------------------------
  240.    -- CPP_Set_Inheritance_Depth --
  241.    -------------------------------
  242.  
  243.    procedure CPP_Set_Inheritance_Depth
  244.      (T     : Vtable_Ptr;
  245.       Value : Natural)
  246.    is
  247.    begin
  248.       T.TSD.Idepth := Value;
  249.    end CPP_Set_Inheritance_Depth;
  250.  
  251.    -----------------------------
  252.    -- CPP_Set_Prim_Op_Address --
  253.    -----------------------------
  254.  
  255.    procedure CPP_Set_Prim_Op_Address
  256.      (T        : Vtable_Ptr;
  257.       Position : Positive;
  258.       Value    : Address)
  259.    is
  260.    begin
  261.       T.Prims_Ptr (Position).Pfn := Value;
  262.    end CPP_Set_Prim_Op_Address;
  263.  
  264.    -----------------
  265.    -- CPP_Set_TSD --
  266.    -----------------
  267.  
  268.    procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
  269.    begin
  270.       T.TSD := To_Type_Specific_Data_Ptr (Value);
  271.    end CPP_Set_TSD;
  272.  
  273.    -------------------
  274.    -- Expanded_Name --
  275.    -------------------
  276.  
  277.    function Expanded_Name (T : Vtable_Ptr) return String is
  278.       Result : Cstring_Ptr := T.TSD.Expanded_Name;
  279.  
  280.    begin
  281.       return Result (1 .. Length (Result));
  282.    end Expanded_Name;
  283.  
  284.    ------------------
  285.    -- External_Tag --
  286.    ------------------
  287.  
  288.    function External_Tag (T : Vtable_Ptr) return String is
  289.       Result : Cstring_Ptr := T.TSD.External_Tag;
  290.  
  291.    begin
  292.       return Result (1 .. Length (Result));
  293.    end External_Tag;
  294.  
  295.    ------------
  296.    -- Length --
  297.    ------------
  298.  
  299.    function Length (Str : Cstring_Ptr) return Natural is
  300.       Len : Integer := 1;
  301.  
  302.    begin
  303.       while Str (Len) /= Ascii.Nul loop
  304.          Len := Len + 1;
  305.       end loop;
  306.  
  307.       return Len - 1;
  308.    end Length;
  309.  
  310. end Interfaces.CPP;
  311.